home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DATETIME.SWG / 0054_Various Date-Time routines.pas < prev    next >
Pascal/Delphi Source File  |  1995-02-28  |  15KB  |  504 lines
  1.  
  2.  (* * * * * * * * * * * * * * * * * * * * * * *)
  3.  (*  UNIT: DTIME - By Alan Graff, Nov. 92*)
  4.  (* Compiled from routines found in: *)
  5.  (*  DATEPAK4: W.G.Madison, Nov. 87 *)
  6.  (*  UNIXDATE: Brian Stark, Jan. 92 *)
  7.  (*  Plus various things of my own creation *)
  8.  (*  and extracted from Fidonet PASCAL echo *)
  9.  (*  messages and other sources. *)
  10.  (* Contributed to the Public Domain *)
  11.  (* Version 1.1 - Nov. 1992 *)
  12.  (* * * * * * * * * * * * * * * * * * * * * * *)
  13.  
  14. UNIT DTime;
  15. {**************************************************************}
  16. INTERFACE
  17. uses crt,dos;
  18.  
  19. TYPE DATETYPE = record
  20.  day:WORD;
  21.  MONTH:WORD;
  22.  YEAR:WORD;
  23.  dow:word;
  24.  end;
  25.  
  26.  (* Sundry determinations of current date/time variables *)
  27. Function DayOfYear:word; (* Returns 1 to 365 *)
  28. Function DayOfMonth:word; (* Returns 1 to 31 *)
  29. Function DayOfWeek:word;  (* Returns 1 to 7  *)
  30. Function MonthOfYear:word; (* Returns 1 to 12 *)
  31. Function ThisYear:word;(* Returns current year *)
  32. Function ThisHour:word;(* Returns 1 to 24 *)
  33. Function ThisMinute:word; (* Returns 0 to 59 *)
  34.  (* Calculate what day of the week a particular date falls on *)
  35. Procedure WkDay(Year,Month,Day:Integer; var WeekDay:Integer);
  36.   (* Full Julian conversions *)
  37. Procedure GregorianToJulianDN(Year,Month,Day:Integer;var JulianDN:LongInt);
  38. Procedure JulianDNToGregorian(JulianDN:LongInt;var Year,Month,Day:Integer);
  39.   (* 365 day Julian conversions *)
  40. Procedure GregorianToJulianDate(Year,Month,Day:Integer;var JulianDate:Integer);
  41. Procedure JulianToGregorianDate(JulianDate,Year:Integer;var Month,Day:Integer);
  42.   (* Sundry string things *)
  43. Function DateString:String; (* Returns system date as "mm-dd-yy" string *)
  44. Function TimeString:String; (* Returns system time as "00:00:00" string *)
  45.  (* Create current YYMMDD string to use as a file name *)
  46. Function DateAFile(dy,dm,dd:word):string;
  47.  (* Return YY-MM-DD string from filename created by DateAFile func *)
  48. Function Parsefile(s:string):string;
  49.   (* Return values of 1 day ago *)
  50. Procedure Yesterday(Var y,m,d:integer);
  51.   (* Return values of 1 day ahead *)
  52. Procedure Tomorrow(Var y,m,d:integer);
  53.  (* Adjust time based on "TZ" environment *)
  54. Function GetTimeZone : ShortInt;
  55. Function IsLeapYear(Source : Word) : Boolean; (* What it says :-) *)
  56.  (* Unix date conversions *)
  57. Function Norm2Unix(Y,M,D,H,Min,S:Word):LongInt;
  58. Procedure Unix2Norm(Date:LongInt;Var Y,M,D,H,Min,S:Word);
  59.  (* Determines what day of year Easter falls on *)
  60. Procedure Easter(Year:Word;Var Date:DateType);
  61.  (* Determines what day of year Thanksgiving falls on *)
  62. Procedure Thanksgiving(Year:Word;Var Date:DateType);
  63.  (* Determine what percentage of moon is lit on a particular night *)
  64. Function MoonPhase(Date:Datetype):Real;
  65.  
  66. IMPLEMENTATION
  67.  
  68. const
  69.  D0 =1461;
  70.  D1 = 146097;
  71.  D2 = 1721119;
  72.  DaysPerMonth : Array[1..12] of ShortInt =
  73. (031,028,031,030,031,030,031,031,030,031,030,031);
  74.  DaysPerYear : Array[1..12] of Integer =
  75. (031,059,090,120,151,181,212,243,273,304,334,365);
  76.  DaysPerLeapYear :Array[1..12] of Integer =
  77. (031,060,091,121,152,182,213,244,274,305,335,366);
  78.  SecsPerYear : LongInt = 31536000;
  79.  SecsPerLeapYear : LongInt = 31622400;
  80.  SecsPerDay  : LongInt = 86400;
  81.  SecsPerHour : Integer = 3600;
  82.  SecsPerMinute: ShortInt = 60;
  83.  
  84. Procedure GregorianToJulianDN;
  85. var
  86.  Century,
  87.  XYear: LongInt;
  88. begin {GregorianToJulianDN}
  89.  If Month <= 2 then begin
  90. Year := pred(Year);
  91. Month := Month + 12;
  92. end;
  93.  Month := Month - 3;
  94.  Century := Year div 100;
  95.  XYear := Year mod 100;
  96.  Century := (Century * D1) shr 2;
  97.  XYear := (XYear * D0) shr 2;
  98.  JulianDN := ((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century;
  99.  end; {GregorianToJulianDN}
  100. {**************************************************************}
  101. Procedure JulianDNToGregorian;
  102. var
  103.  Temp,
  104.  XYear  : LongInt;
  105.  YYear,
  106.  YMonth,
  107.  YDay: Integer;
  108. begin {JulianDNToGregorian}
  109.  Temp := (((JulianDN - D2) shl 2) - 1);
  110.  XYear := (Temp mod D1) or 3;
  111.  JulianDN := Temp div D1;
  112.  YYear := (XYear div D0);
  113.  Temp := ((((XYear mod D0) + 4) shr 2) * 5) - 3;
  114.  YMonth := Temp div 153;
  115.  If YMonth >= 10 then begin
  116. YYear := YYear + 1;
  117. YMonth := YMonth - 12;
  118. end;
  119.  YMonth := YMonth + 3;
  120.  YDay := Temp mod 153;
  121.  YDay := (YDay + 5) div 5;
  122.  Year := YYear + (JulianDN * 100);
  123.  Month := YMonth;
  124.  Day := YDay;
  125.  end; {JulianDNToGregorian}
  126. {**************************************************************}
  127. Procedure GregorianToJulianDate;
  128. var
  129.  Jan1,
  130.  Today : LongInt;
  131. begin {GregorianToJulianDate}
  132.  GregorianToJulianDN(Year, 1, 1, Jan1);
  133.  GregorianToJulianDN(Year, Month, Day, Today);
  134.  JulianDate := (Today - Jan1 + 1);
  135.  end; {GregorianToJulianDate}
  136. {**************************************************************}
  137. Procedure JulianToGregorianDate;
  138. var
  139.  Jan1 : LongInt;
  140. begin
  141.  GregorianToJulianDN(Year, 1, 1, Jan1);
  142.  JulianDNToGregorian((Jan1 + JulianDate - 1), Year, Month, Day);
  143.  end; {JulianToGregorianDate}
  144. {**************************************************************}
  145. Procedure WkDay;
  146. var
  147.  DayNum : LongInt;
  148. begin
  149.  GregorianToJulianDN(Year, Month, Day, DayNum);
  150.  DayNum := ((DayNum + 1) mod 7);
  151.  WeekDay := (DayNum) + 1;
  152.  end; {DayOfWeek}
  153. {**************************************************************}
  154. Procedure Yesterday(Var Y,M,D:integer);
  155. var jdn:longint;
  156. begin
  157. GregorianToJulianDN(Y,M,D,JDN);
  158. JDN:=JDN-1;
  159. JulianDNToGregorian(JDN,Y,M,D);
  160. end;
  161. {**************************************************************}
  162. Procedure Tomorrow(Var Y,M,D:integer);
  163. var JDN:longint;
  164. begin
  165. GregorianToJulianDN(Y,M,D,JDN);
  166. JDN:=JDN+1;
  167. JulianDNToGregorian(JDN,Y,M,D);
  168. end;
  169. {**************************************************************}
  170. Function TimeString:string;
  171. var hr,mn,sec,hun:word;
  172. s,q:string;
  173. begin
  174.  q:='';
  175.  gettime(hr,mn,sec,hun);
  176.  if hr<10 then q:=q+'0';
  177.  str(hr:1,s);
  178.  q:=q+s+':';
  179.  if mn<10 then q:=q+'0';
  180.  str(mn:1,s);
  181.  q:=q+s;
  182.  TimeString:=q;
  183. end;
  184. {**************************************************************}
  185. Function ThisHour:Word;
  186. var hr,mn,sec,hun:word;
  187. begin
  188.  gettime(hr,mn,sec,hun);
  189.  ThisHour:=hr;
  190. end;
  191. {**************************************************************}
  192. Function ThisMinute:Word;
  193. var hr,mn,sec,hun:word;
  194. begin
  195.  gettime(hr,mn,sec,hun);
  196.  ThisMinute:=mn;
  197. end;
  198. {**************************************************************}
  199. Function DateString:string;
  200. var yr,mo,dy,dow:word;
  201. s,q:string;
  202. begin
  203.  q:='';
  204.  getdate(yr,mo,dy,dow);
  205.  if mo<10 then q:=q+'0';
  206.  str(mo:1,s);
  207.  q:=q+s+'-';
  208.  if dy<10 then q:=q+'0';
  209.  str(dy:1,s);
  210.  q:=q+s+'-';
  211.  while yr>100 do yr:=yr-100;
  212.  if yr<10 then q:=q+'0';
  213.  str(yr:1,s);
  214.  q:=q+s;
  215.  Datestring:=q;
  216. end;
  217. {**************************************************************}
  218. Function parsefile(s:string):string; { Return date string from a file name }
  219. var mo,errcode:word; { in either YYMMDD.EXT or MMDDYY.EXT }
  220. st:string;{ format. }
  221. begin
  222. st:=copy(s,1,2)+'-'+copy(s,3,2)+'-'+copy(s,5,2);
  223. parsefile:=st;
  224. end;
  225. {**************************************************************}
  226. function dateafile(dy,dm,dd:word):string;
  227. var s1,s2:string;
  228. begin
  229. while dy>100 do dy:=dy-100;
  230. str(dy,s1);
  231. while length(s1)<2 do s1:='0'+s1;
  232. s2:=s1;
  233. str(dm,s1);
  234. while length(s1)<2 do s1:='0'+s1;
  235. s2:=s2+s1;
  236. str(dd,s1);
  237. while length(s1)<2 do s1:='0'+s1;
  238. s2:=s2+s1;
  239. dateafile:=s2;
  240. end;
  241. {**************************************************************}
  242. Function DayOfMonth:Word;
  243. var yr,mo,dy,dow:word;
  244. begin
  245.  getdate(yr,mo,dy,dow);
  246.  DayOfMonth:=dy;
  247. end;
  248. {**************************************************************}
  249. Function ThisYear:Word;
  250. var yr,mo,dy,dow:word;
  251. begin
  252.  getdate(yr,mo,dy,dow);
  253.  ThisYear:=yr;
  254. end;
  255.  
  256. {**************************************************************}
  257. Function DayOfWeek:word;
  258. var yr,mo,dy,dow:word;
  259. begin
  260.  getdate(yr,mo,dy,dow);(* Turbo Pascal authors never saw a *)
  261.  dow:=dow+1;  (* calendar. Their first day of*)
  262.  if dow=8 then dow:=1; (* week is Monday....  *)
  263.  DayOfWeek:=dow;
  264. end;
  265. {**************************************************************}
  266. Function MonthOfYear:Word;
  267. var yr,mo,dy,dow:word;
  268. begin
  269.  getdate(yr,mo,dy,dow);
  270.  monthofyear:=mo;
  271. end;
  272. {**************************************************************}
  273. Function GetTimeZone : ShortInt;
  274. Var
  275.  Environment : String;
  276.  Index : Integer;
  277. Begin
  278.  GetTimeZone := 0;{Assume UTC}
  279.  Environment := GetEnv('TZ');  {Grab TZ string}
  280.  For Index := 1 To Length(Environment) Do
  281. Environment[Index] := Upcase(Environment[Index]);
  282.  If Environment = 'EST05'Then GetTimeZone := -05; {USA EASTERN}
  283.  If Environment = 'EST05EDT' Then GetTimeZone := -06;
  284.  If Environment = 'CST06'Then GetTimeZone := -06; {USA CENTRAL}
  285.  If Environment = 'CST06CDT' Then GetTimeZone := -07;
  286.  If Environment = 'MST07'Then GetTimeZone := -07; {USA MOUNTAIN}
  287.  If Environment = 'MST07MDT' Then GetTimeZone := -08;
  288.  If Environment = 'PST08'Then GetTimeZone := -08;
  289.  If Environment = 'PST08PDT' Then GetTimeZone := -09;
  290.  If Environment = 'YST09'Then GetTimeZone := -09;
  291.  If Environment = 'AST10'Then GetTimeZone := -10;
  292.  If Environment = 'BST11'Then GetTimeZone := -11;
  293.  If Environment = 'CET-1'Then GetTimeZone := 01;
  294.  If Environment = 'CET-01'  Then GetTimeZone := 01;
  295.  If Environment = 'EST-10'  Then GetTimeZone := 10;
  296.  If Environment = 'WST-8'Then GetTimeZone := 08; {Perth,W.Austrailia}
  297.  If Environment = 'WST-08'  Then GetTimeZone := 08;
  298. End;
  299. {**************************************************************}
  300. Function IsLeapYear(Source : Word) : Boolean;
  301. Begin
  302.  If (Source Mod 4 = 0) Then
  303. IsLeapYear := True
  304.  Else
  305. IsLeapYear := False;
  306. End;
  307. {**************************************************************}
  308. Function Norm2Unix(Y,M,D,H,Min,S : Word) : LongInt;
  309. Var
  310.  UnixDate : LongInt;
  311.  Index: Word;
  312. Begin
  313.  UnixDate := 0; {initialize}
  314.  Inc(UnixDate,S);  {add seconds}
  315.  Inc(UnixDate,(SecsPerMinute * Min));  {add minutes}
  316.  Inc(UnixDate,(SecsPerHour * H)); {add hours}
  317.  UnixDate := UnixDate - (GetTimeZone * SecsPerHour); {UTC offset}
  318.  If D > 1 Then {has one day already passed?}
  319. Inc(UnixDate,(SecsPerDay * (D-1)));
  320.  If IsLeapYear(Y) Then
  321. DaysPerMonth[02] := 29
  322.  Else
  323. DaysPerMonth[02] := 28; {Check for Feb. 29th}
  324.  Index := 1;
  325.  If M > 1 Then For Index := 1 To (M-1) Do {has one month already passed?}
  326. Inc(UnixDate,(DaysPerMonth[Index] * SecsPerDay));
  327.  While Y > 1970 Do
  328.  Begin
  329. If IsLeapYear((Y-1)) Then
  330.  Inc(UnixDate,SecsPerLeapYear)
  331. Else
  332.  Inc(UnixDate,SecsPerYear);
  333. Dec(Y,1);
  334.  End;
  335.  Norm2Unix := UnixDate;
  336. End; Procedure Unix2Norm(Date : LongInt; Var Y, M, D, H, Min, S : Word);
  337. {}
  338. Var
  339.  LocalDate : LongInt; Done : Boolean; X : ShortInt; TotDays : Integer;
  340. Begin
  341.  Y  := 1970; M := 1; D := 1; H := 0; Min := 0; S := 0;
  342.  LocalDate := Date + (GetTimeZone * SecsPerHour); {Local time date}
  343.  Done := False;
  344.  While Not Done Do
  345.  Begin
  346. If LocalDate >= SecsPerYear Then
  347. Begin
  348.  Inc(Y,1);
  349.  Dec(LocalDate,SecsPerYear);
  350. End
  351. Else
  352.  Done := True;
  353. If (IsLeapYear(Y+1)) And (LocalDate >= SecsPerLeapYear) And
  354.   (Not Done) Then
  355. Begin
  356.  Inc(Y,1);
  357.  Dec(LocalDate,SecsPerLeapYear);
  358. End;
  359.  End;
  360.  M := 1; D := 1;
  361.  Done := False;
  362.  TotDays := LocalDate Div SecsPerDay;
  363.  If IsLeapYear(Y) Then
  364.  Begin
  365. DaysPerMonth[02] := 29;
  366. X := 1;
  367. Repeat
  368.  If (TotDays <= DaysPerLeapYear[x]) Then
  369.  Begin
  370. M := X;
  371. Done := True;
  372. Dec(LocalDate,(TotDays * SecsPerDay));
  373. D := DaysPerMonth[M]-(DaysPerLeapYear[M]-TotDays) + 1;
  374.  End
  375.  Else
  376. Done := False;
  377.  Inc(X);
  378. Until (Done) or (X > 12);
  379.  End
  380.  Else
  381.  Begin
  382. DaysPerMonth[02] := 28;
  383. X := 1;
  384. Repeat
  385.  If (TotDays <= DaysPerYear[x]) Then
  386.  Begin
  387. M := X;
  388. Done := True;
  389. Dec(LocalDate,(TotDays * SecsPerDay));
  390. D := DaysPerMonth[M]-(DaysPerYear[M]-TotDays) + 1;
  391.  End
  392.  Else
  393. Done := False;
  394.  Inc(X);
  395. Until Done = True or (X > 12);
  396.  End;
  397.  H := LocalDate Div SecsPerHour;
  398. Dec(LocalDate,(H * SecsPerHour));
  399.  Min := LocalDate Div SecsPerMinute;
  400. Dec(LocalDate,(Min * SecsPerMinute));
  401.  S := LocalDate;
  402. End;
  403. {**************************************************************}
  404. Function DayOfYear;
  405. var
  406.  HCentury,Century,Xyear,
  407.  Ripoff,HXYear: LongInt;
  408.  Holdyear,Holdmonth,Holdday:Integer;
  409.  year,month,day,dofwk:word;
  410. begin {DayofYear}
  411.  getdate(year,month,day,dofwk);
  412.  Holdyear:=year-1;
  413.  Holdmonth:=9;
  414.  Holdday:=31;
  415.  HCentury := HoldYear div 100;
  416.  HXYear := HoldYear mod 100;
  417.  HCentury := (HCentury * D1) shr 2;
  418.  HXYear := (HXYear * D0) shr 2;
  419.  Ripoff := ((((HoldMonth * 153) + 2) div 5) + HoldDay) + D2 + HXYear +
  420. HCentury;
  421.  If Month <= 2 then begin
  422. Year := pred(Year);
  423. Month := Month + 12;
  424. end;
  425.  Month := Month - 3;
  426.  Century := Year div 100;
  427.  XYear := Year mod 100;
  428.  Century := (Century * D1) shr 2;
  429.  XYear := (XYear * D0) shr 2;
  430.  DayofYear := (((((Month * 153) + 2) div 5) + Day) + D2 + XYear + Century)-
  431. ripoff;
  432.  end; {DayOfYear}
  433. Procedure Easter(Year : Word; Var Date : DateType);
  434.   (* Calculates what day Easter falls on in a given year *)
  435.   (* Set desired Year and result is returned in Date variable*)
  436. Var
  437.   GoldenNo,
  438.   Sun,
  439.   Century,
  440.   LeapCent,
  441.   LunarCorr,
  442.   Epact,
  443.   FullMoon : Integer;
  444. Begin
  445.   Date.Year := Year;
  446.   GoldenNo := (Year Mod 19) + 1;
  447.   Century := (Year Div 100) + 1;
  448.   LeapCent := (3 * Century Div 4) - 12;
  449.   LunarCorr := ((8 * Century + 5) Div 25) - 5;
  450.   Sun := (5 * Year Div 4) - LeapCent - 10;
  451.   Epact := Abs(11 * GoldenNo + 20 + LunarCorr - LeapCent) Mod 30;
  452.   If ((Epact = 25) And (GoldenNo > 11)) Or (Epact = 24) then
  453.  Inc(Epact);
  454.   FullMoon := 44 - Epact;
  455.   If FullMoon < 21 then
  456.  Inc(FullMoon, 30);
  457.   Date.Day := FullMoon + 7 - ((Sun + FullMoon) Mod 7);
  458.   If Date.Day > 31 then
  459.  Begin
  460.  Dec(Date.Day, 31);
  461.  Date.Month := 4;
  462.  End
  463.   Else
  464.  Date.Month := 3;
  465.   Date.DOW := 0;
  466. End;
  467. {**************************************************************}
  468. Procedure Thanksgiving(Year : Word; Var Date : DateType);
  469.   (* Calculates what day Thanksgiving falls on in a given year  *)
  470.   (* Set desired Year and result is returned in Date variable*)
  471. Var
  472.  Counter,WeekDay:Word;
  473.  Daynum:longint;
  474. Begin
  475.   Date.Year := Year;
  476.   Date.Month := 11;
  477.   counter:=29;
  478.   repeat
  479.  dec(counter);
  480.  GregorianToJulianDN(Date.Year, Date.Month, Counter, DayNum);
  481.  DayNum := ((DayNum + 1) mod 7);
  482.  WeekDay := (DayNum) + 1;
  483.   Until Weekday = 5;
  484.   Date.Day:=Counter;
  485. End;
  486. {*************************************************************}
  487. Function MoonPhase(Date:Datetype):Real;
  488.  (* Determines APPROXIMATE phase of the moon (percentage lit)  *)
  489.  (* 0.00 = New moon, 1.00 = Full moon  *)
  490.  (* Due to rounding, full values may possibly never be reached *)
  491.  (* Valid from Oct. 15, 1582 to Feb. 28, 4000  *)
  492.  (* Calculations adapted to Turbo Pascal from routines found in *)
  493.  (* "119 Practical Programs For The TRS-80 Pocket Computer" *)
  494.  (* John Clark Craig, TAB Books, 1982 (Ag) *)
  495. VAR j:longint; m:real;
  496. Begin
  497.  GregorianToJulianDN(Date.Year,Date.Month,Date.Day,J);
  498.  M:=(J+4.867)/ 29.53058;
  499.  M:=2*(M-Int(m))-1;
  500.  MoonPhase:=Abs(M);
  501. end;
  502.  
  503. END.
  504.